unit dorm.Mappings.Strategies;

interface

uses
  Rtti,
  Generics.Collections,
  superobject,
  dorm.Commons,
  dorm.Mappings;

type
  IMappingStrategy = interface
    ['{F64D6AF3-C4C2-4098-A241-B3401CE3FB03}']
    procedure GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
  end;

  ICacheMappingStrategy = interface
    ['{B8C136E4-7C71-4D09-9016-61D2B2271EFE}']
    function GetMapping(const AType: TRttiType): TMappingTable;
    procedure Add(const AMappingStrategy: IMappingStrategy);
  end;

  TMappingTableMerger = class
  private
    function BelongsToAlreadyAdded(const Name: String; Output: TMappingTable): Boolean;
    function FieldAlreadyAdded(const Name: String; Output: TMappingTable): Boolean;
    function RelAlreadyAdded(const Name: String; const List: TObjectList<TMappingRelation>): Boolean;
  public
    procedure Merge(Output: TMappingTable; Input: array of TMappingTable);
  end;

  TCacheMappingStrategy = class(TInterfacedObject, ICacheMappingStrategy)
  private
    FMerger: TMappingTableMerger;
    FMappingStrategies: TList<IMappingStrategy>;
    FMappings: TDictionary<TRttiType, TMappingTable>;
    function GetMapping(const AType: TRttiType): TMappingTable;
    procedure Add(const AMappingStrategy: IMappingStrategy);
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TFileMappingStrategy = class(TInterfacedObject, IMappingStrategy)
  private
    FConfig: ISuperObject;
    FEnviroment: string;
    procedure GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
    procedure ParseField(const Field: TMappingField; const Json: ISuperObject);
    procedure ParseHasMany(const AHasMany: TMappingRelation;
      const Json: ISuperObject);
    procedure ParseHasOne(const AHasOne: TMappingRelation;
      const Json: ISuperObject);
    procedure ParseBelongTo(const ABelongTo: TMappingBelongTo;
      const Json: ISuperObject);
    procedure ParseIdField(const ClassName: String; AMappingTable: TMappingTable; const ATable: ISuperObject);
  public
    constructor Create(const AConfig: ISuperObject; const AEnviroment: string);
  end;

  TAttributesMappingStrategy = class(TInterfacedObject, IMappingStrategy)
  private
    procedure GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
  end;

  TCoCMappingStrategy = class(TInterfacedObject, IMappingStrategy)
  private
    { Checks whether a given type is a candidate for a duck list.
      These conditions must be met:
      Have an Add method with a single argument of any type
      Have a Clear method with no argument
      Have a GetItem method with one argument of type Integer and that
      returns the same type used on Add method
      Have a Count property of type integer.  }
    function IsACollectionClass(const AType: TRttiType; out ElementType: TRttiType): Boolean;
    function SkipClassPrefix(const ClassName: String): String;
    procedure ParseFields(const Table: TMappingTable; const AType: TRttiType);
    procedure ParseHasOne(const Table: TMappingTable; const AType: TRttiType);
    procedure ParseHasMany(const Table: TMappingTable; const AType: TRttiType);
    procedure GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
  end;

implementation

uses
  SysUtils, StrUtils, dorm.Utils, Typinfo, Classes;

{ TCacheMappingStrategy }

procedure TCacheMappingStrategy.Add(const AMappingStrategy: IMappingStrategy);
begin
  FMappingStrategies.Add(AMappingStrategy);
end;

constructor TCacheMappingStrategy.Create;
begin
  inherited Create;
  FMerger := TMappingTableMerger.Create;
  FMappings := TDictionary<TRttiType, TMappingTable>.Create(128);
  FMappingStrategies := TList<IMappingStrategy>.Create;
end;

destructor TCacheMappingStrategy.Destroy;
var
  maptable: TMappingTable;
begin
  FMerger.Free;
  FMappingStrategies.Clear;
  FMappingStrategies.Free;
  for maptable in FMappings.Values do
    maptable.Free;
  FMappings.Free;
  inherited;
end;

function TCacheMappingStrategy.GetMapping(const AType: TRttiType): TMappingTable;
var
  MappingTables: array of TMappingTable;
  i: Integer;
begin
  if not FMappings.TryGetValue(AType, Result) then
  begin
    Result := TMappingTable.Create;
    SetLength(MappingTables, FMappingStrategies.Count);
    for i := 0 to High(MappingTables) do
      MappingTables[i] := TMappingTable.Create;
    try
      for i := 0 to High(MappingTables) do
        FMappingStrategies[i].GetMapping(AType, MappingTables[i]);
      FMerger.Merge(Result, MappingTables);
      if Result.TableName = '' then
        raise Exception.Create(Format('Cound not find mapping to Class %s', [AType.ClassName]));
      FMappings.Add(AType, Result);
    finally
      for i := 0 to High(MappingTables) do
        MappingTables[i].Free;
    end;
  end;
end;

{ TFileMappingStrategy }


constructor TFileMappingStrategy.Create(const AConfig: ISuperObject; const AEnviroment: string);
begin
  inherited Create;
  FConfig := AConfig;
  FEnviroment := AEnviroment;
end;

procedure TFileMappingStrategy.ParseIdField(const ClassName: String; AMappingTable: TMappingTable; const ATable: ISuperObject);
var
  _persistenceCfg: ISuperObject;
  IdField: TMappingField;
begin
  IdField := AMappingTable.AddField;
  with AMappingTable do
  begin
    ParseField(IdField, ATable.O['id']);
    IdField.IsPK := True;
    if (SameText(ATable.S['key_type'], 'integer')) then
    begin
      IdType := ktInteger;
      IdNullValue := ATable.I['null_key_value'];
    end
    else if (SameText(ATable.S['key_type'], 'string')) then
    begin
      IdType := ktString;
      IdNullValue := ATable.S['null_key_value'];
    end
    else
    begin
      _persistenceCfg := FConfig.O['persistence'].O[FEnviroment];
      if (SameText(_persistenceCfg.S['key_type'], 'integer')) then
      begin
        IdType := ktInteger;
        IdNullValue := _persistenceCfg.I['null_key_value'];
      end
      else if (SameText(_persistenceCfg.S['key_type'], 'string')) then
      begin
        IdType := ktString;
        IdNullValue := _persistenceCfg.S['null_key_value'];
      end
      else
        raise EdormException.CreateFmt('Unknown key type for %s.%s', [ClassName, Id.Name]);
    end;
  end;
end;

procedure TFileMappingStrategy.ParseField(const Field: TMappingField;
  const Json: ISuperObject);
var
  _IndexType: string;
begin
  Field.Name := Json.S['name'];
  Field.FieldName := Json.S['field'];
  Field.Size := Json.I['size'];
  Field.FieldType := Json.S['field_type'];
  Field.DefaultValue := Json.S['default_value'];
  Field.Precision := Json.I['precision'];
  Field.IndexType := itNone;
  _IndexType := Json.S['index_type'];
  if SameText(_IndexType, 'index') then
    Field.IndexType := itIndex
  else if SameText(_IndexType, 'unique') then
    Field.IndexType := itUnique;
  Field.IsPK := false;
end;

procedure TFileMappingStrategy.ParseHasOne(const AHasOne: TMappingRelation;
  const Json: ISuperObject);
begin
  AHasOne.Name := Json.S['name'];
  AHasOne.ChildClassName := Json.S['class_name'];
  AHasOne.ChildFieldName := Json.S['child_field_name'];
  AHasOne.LazyLoad := Json.B['lazy_load'];
end;

procedure TFileMappingStrategy.ParseHasMany(const AHasMany: TMappingRelation;
  const Json: ISuperObject);
begin
  AHasMany.Name := Json.S['name'];
  AHasMany.ChildClassName := Json.S['class_name'];
  AHasMany.ChildFieldName := Json.S['child_field_name'];
  AHasMany.LazyLoad := Json.B['lazy_load'];
end;

procedure TFileMappingStrategy.ParseBelongTo(const ABelongTo: TMappingBelongTo;
  const Json: ISuperObject);
begin
  ABelongTo.Name := Json.S['name'];
  ABelongTo.OwnerClassName := Json.S['class_name'];
  ABelongTo.RefFieldName := Json.S['ref_field_name'];
  ABelongTo.LazyLoad := Json.B['lazy_load'];
end;

procedure TFileMappingStrategy.GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
var
  Arr: TSuperArray;
  Table: ISuperObject;
  i: Integer;
begin
  Table := FConfig.O['mapping'].O[AType.Name];
  if not Assigned(Table) then
    Exit;

  AMappingTable.TableName := Table.S['table'];
  AMappingTable.Package := Table.S['package'];

  ParseIdField(AType.Name, AMappingTable, Table);
  Arr := Table.O['fields'].AsArray;
  if Assigned(Arr) then
  begin
    for i := 0 to Arr.Length - 1 do
      ParseField(AMappingTable.AddField, Arr[i]);
  end;

  Arr := Table.A['has_one'];
  if Assigned(Arr) then
    for i := 0 to Arr.Length - 1 do
      ParseHasOne(AMappingTable.AddHasOne, Arr[i]);

  Arr := Table.A['has_many'];
  if Assigned(Arr) then
    for i := 0 to Arr.Length - 1 do
      ParseHasMany(AMappingTable.AddHasMany, Arr[i]);

  Arr := Table.A['belongs_to'];
  if Assigned(Arr) then
    for i := 0 to Arr.Length - 1 do
      ParseBelongTo(AMappingTable.AddBelongTo, Arr[i]);
end;

{ TAttributesMappingStrategy }

procedure TAttributesMappingStrategy.GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
begin

end;

{ TCoCMappingStrategy }

procedure TCoCMappingStrategy.GetMapping(const AType: TRttiType; AMappingTable: TMappingTable);
begin
  AMappingTable.TableName := AnsiUpperCase(SkipClassPrefix(AType.Name));
  AMappingTable.Package := AType.AsInstance.MetaclassType.UnitName;
  ParseFields(AMappingTable, AType);
  ParseHasOne(AMappingTable, AType);
  ParseHasMany(AMappingTable, AType);
end;

function TCoCMappingStrategy.IsACollectionClass(
  const AType: TRttiType; out ElementType: TRttiType): Boolean;

  function GetMethod(const Name: String; const ArgCount: Integer; out Method: TRttiMethod): Boolean;
  begin
    Method := AType.GetMethod(Name);
    Result := Assigned(Method) and (Length(Method.GetParameters) = ArgCount);
  end;

var
  Method: TRttiMethod;
  Prop: TRttiProperty;
begin
  // Check Add
  if not GetMethod('Add', 1, Method) then
    Exit(False);
  ElementType := Method.GetParameters[0].ParamType;

  // Check Clear
  if not GetMethod('Clear', 0, Method) then
    Exit(False);

  // Check GetItem
  if not GetMethod('GetItem', 1, Method) then
    Exit(False);
  if Method.GetParameters[0].ParamType.Handle <> TypeInfo(Integer) then
    Exit(False);
  if Method.ReturnType <> ElementType then
    Exit(False);

  // Check Count
  Prop := AType.GetProperty('Count');
  if not Assigned(Prop) then
    Exit(False);
  if Prop.PropertyType.Handle <> TypeInfo(Integer) then
    Exit(False);

  Result := True;
end;

procedure TCoCMappingStrategy.ParseFields(const Table: TMappingTable;
  const AType: TRttiType);
var
  Prop: TRttiProperty;
  Field: TMappingField;
  FieldType: String;
  PropInfo: PTypeInfo;
begin
  for Prop in AType.GetProperties do
  begin
    if TdormUtils.HasAttribute<Transient>(Prop) then
      Continue;

    PropInfo := Prop.PropertyType.Handle;
    if PropInfo.Kind in [tkString, tkWString, tkChar, tkWChar, tkLString, tkUString] then
      FieldType := 'string'
    else if PropInfo.Kind in [tkInteger, tkInt64] then
      FieldType := 'integer'
    else if PropInfo = TypeInfo(TDate) then
      FieldType := 'date'
    else if PropInfo = TypeInfo(TDateTime) then
      FieldType := 'datetime'
    else if Prop.PropertyType.IsInstance and Prop.PropertyType.AsInstance.MetaclassType.InheritsFrom(TStream) then
      FieldType := 'blob'
    else
      Continue;

    Field := Table.AddField;
    if AnsiUpperCase(Prop.Name) = 'ID' then
    begin
      Field.IsPK := True;
      if FieldType = 'string' then
        Table.IdType := ktString
      else if FieldType = 'integer' then
        Table.IdType := ktInteger
    end;
    Field.Name := Prop.Name;
    Field.FieldName := AnsiUpperCase(Prop.Name);
    Field.FieldType := FieldType;
  end;
end;

procedure TCoCMappingStrategy.ParseHasMany(const Table: TMappingTable;
  const AType: TRttiType);
var
  Prop: TRttiProperty;
  Rel: TMappingRelation;
  ElementType: TRttiType;
begin
  for Prop in AType.GetProperties do
  begin
    if Prop.PropertyType.IsInstance then
    begin
      if IsACollectionClass(Prop.PropertyType, ElementType) then
      begin
        Rel := Table.AddHasMany;
        Rel.Name := Prop.Name;
        Rel.ChildClassName := ElementType.Name;
        Rel.ChildFieldName := SkipClassPrefix(AType.Name) + 'ID';
        Rel.LazyLoad := False;
      end;
    end;
  end;
end;

procedure TCoCMappingStrategy.ParseHasOne(const Table: TMappingTable;
  const AType: TRttiType);
var
  Prop: TRttiProperty;
  Rel: TMappingRelation;
  PropType: TClass;
  ElementType: TRttiType;
begin
  for Prop in AType.GetProperties do
  begin
    if Prop.PropertyType.IsInstance then
    begin
      PropType := Prop.PropertyType.AsInstance.MetaclassType;
      if (not PropType.InheritsFrom(TStream)) and not IsACollectionClass(Prop.PropertyType, ElementType) then
      begin
        Rel := Table.AddHasOne;
        Rel.Name := Prop.Name;
        Rel.ChildClassName := PropType.ClassName;
        Rel.ChildFieldName := SkipClassPrefix(AType.Name) + 'ID';
        Rel.LazyLoad := False;
      end;
    end;
  end;
end;

function TCoCMappingStrategy.SkipClassPrefix(const ClassName: String): String;
begin
  Result := Copy(ClassName, 2);
end;

{ TMappingTableMerger }

procedure TMappingTableMerger.Merge(Output: TMappingTable;
  Input: array of TMappingTable);
var
  MappingTable: TMappingTable;
  Field: TMappingField;
  Rel: TMappingRelation;
  BelongsTo: TMappingBelongTo;
begin
  for MappingTable in Input do
  begin
    if Output.TableName = '' then
      Output.TableName := MappingTable.TableName;

    if Output.Package = '' then
      Output.Package := MappingTable.Package;

    for Field in MappingTable.Fields do
    begin
      if FieldAlreadyAdded(Field.Name, Output) then
        Continue;

      Output.AddField.Assign(Field);

      { When copying the PK field from any mappingtable, copy also some other
        PK related fields from the same mappingtable }
      if Field.IsPK then
      begin
        Output.IdType := MappingTable.IdType;
        Output.IdNullValue := MappingTable.IdNullValue;
      end;
    end;

    for Rel in MappingTable.HasOneList do
    begin
      if RelAlreadyAdded(Rel.Name, Output.HasOneList) then
        Continue;

      Output.AddHasOne.Assign(Rel);
    end;

    for Rel in MappingTable.HasManyList do
    begin
      if RelAlreadyAdded(Rel.Name, Output.HasManyList) then
        Continue;

      Output.AddHasMany.Assign(Rel);
    end;

    for BelongsTo in MappingTable.BelongToList do
    begin
      if BelongsToAlreadyAdded(BelongsTo.Name, Output) then
        Continue;

      Output.AddBelongTo.Assign(BelongsTo);
    end;
  end;
end;

function TMappingTableMerger.FieldAlreadyAdded(const Name: String; Output: TMappingTable): Boolean;
var
  Field: TMappingField;
begin
  Result := False;
  for Field in Output.Fields do
    if AnsiSameText(Field.Name, Name) then
      Exit(True);
end;

function TMappingTableMerger.RelAlreadyAdded(const Name: String; const List: TObjectList<TMappingRelation>): Boolean;
var
  Rel: TMappingRelation;
begin
  Result := False;
  for Rel in List do
    if AnsiSameText(Rel.Name, Name) then
      Exit(True);
end;

function TMappingTableMerger.BelongsToAlreadyAdded(const Name: String; Output: TMappingTable): Boolean;
var
  Rel: TMappingBelongTo;
begin
  Result := False;
  for Rel in Output.BelongToList do
    if AnsiSameText(Rel.Name, Name) then
      Exit(True);
end;

end.
